Pascal Super Library/Pascal Super Library (CW International)(1997).bin/DELPHI32/GRAPHICS/GIF/GIFIMG.PAS

Pascal/Delphi Source File | 1996-04-13 | 36KB | 1,002 lines

{+--------------------------------------------------------------------------+
 | Component: TGifImage & TGif
 | Created: 4/12/96 11:52:35 PM
 | Author: Jeff Kinzer
 | Copyright 1996, all rights reserved.
 | Description: Displays / Converts GIF Files
 | Version: 1.0
 | Revision: 0.1
 | History:
 |    * Borland Pascal      -  GifUtl.pas     Sean Wenzel       ( CompuServe: 71736,1245 )
 |    * Converted to Delphi -  Gif2Bmp.pas    Richard Dominelli ( CompuServe: 73541,2555 )
 |    * Created TGifImage   -  GifImg.pas     Jeff Kinzer       ( CompuServe: 102413,3557 )
 | Unsupported GIF Features:
 |    * Misc. Extension Blocks:
 |        + Graphic Control extension
 |        + Comment extension
 |        + Plain text extension
 |        + Application extension
 | Note: I'm not sure what will happen if these
 |       blocks are encountered but it'll be interesting
 +--------------------------------------------------------------------------+}

unit GifImg;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls, StdCtrls, Menus;

const
{ General Purpose Constants }
    MAXSCREENWIDTH = 800;
    MAXCODES = 4095;                                { the maximum number of different codes 0 inclusive }

type
  TGifStatus = 0..100;

  TStatusChangeEvent = procedure(Sender: TObject; Status: TGifStatus) of object;

  PGifDataSubBlock = ^TGifDataSubBlock;
    TGifDataSubBlock = record
        Size: Byte;                                   { Size of the block -- 0 to 255 }
        Data: array[1..255] of Byte;                  { The data }
    end;

  PGifHeader = ^TGifHeader;
    TGifHeader = record
        Signature: array[0..2] of Char;               { Contains 'GIF' }
        Version: array[0..2] of Char;                 { '87a' or '89a' }
    end;

  TLogicalScreenDescriptor = record
    ScreenWidth: Word;                            { Logical screen width }
    ScreenHeight: Word;                           { Logical screen height }
    PackedFields: Byte;                           { Packed fields (See Below) }
    BackGroundColorIndex: Byte;                   { Index to global color table }
    AspectRatio: Byte;                            { Actual ratio = (AspectRatio + 15) / 64 }
  end;

    TColorItem = record                                    { One item color table }
        Red: Byte;
        Green: Byte;
        Blue: Byte;
    end;

  TColorTable = array[0..255] of TColorItem;          { The color table }

    TGifImageDescriptor = record
        Separator: Byte;                          { Fixed value of ImageSeparator }
        ImageLeftPos: Word;                     { Column in respect to left edge of logical screen }
    ImageTopPos: Word;                      { Row in respect to top of logical screen }
        ImageWidth: Word;                          { Width of image in pixels }
        ImageHeight: Word;                       { Height of image in pixels }
        PackedFields: Byte;                      { See below }
    end;

(*
    TExtensionBlock = record
        Introducer: Byte;                               { Fixed value of ExtensionIntroducer }
        ExtensionLabel: Byte;
        BlockSize: Byte;
  end;

    PGifCodeItem = ^TGifCodeItem;
  TGifCodeItem = record
        Code1,
    Code2: Byte;
  end;
*)

    TGraphicLine = array [0..2048] of Byte;

  TGifVersion = (v87a, v89a);

    PGif = ^TGif;
    TGif = class(TGraphic)
  private
    FGifVersion: TGifVersion;
    FOnChange: TNotifyEvent;
    FOnStatusChange: TStatusChangeEvent;
    FBitmap: TBitmap;
        FInterlaced: Boolean;                                { true if image is interlaced }
    { GIF Data }
        GifStream: TMemoryStream;                      { the file stream for the gif file }
        Header: TGifHeader;                                { gif file header }
        LogicalScreen: TLogicalScreenDescriptor;    { gif screen descriptor }
        GlobalColorTable: TColorTable;                  { global color table }
        LocalColorTable: TColorTable;                      { local color table }
        ImageDescriptor: TGifImageDescriptor;             { image descriptor }
        UseLocalColors: Boolean;                        { true if local colors in use }
        LZWCodeSize: Byte;                                  { minimum size of the LZW codes in bits }
        ImageData: TGifDataSubBlock;                        { variable to store incoming gif data }
        TableSize: Word;                                      { number of entrys in the color table }
        BitsLeft,                                   { bits left in Byte  }
    BytesLeft: Integer;                            { Bytes left in block }
        BadCodeCount: Word;                            { bad code counter }
        CurrCodeSize: Integer;                         { Current size of code in bits }
        ClearCode: Integer;                            { Clear code value }
        EndingCode: Integer;                           { ending code value }
        Slot: Word;                                                { where next new code will be added }
        TopSlot: Word;                                    { highest slot position for the current code size }
        HighCode: Word;                                  { highest code that does not require decoding }
        NextByte: Integer;                            { the index to the next Byte in the datablock array }
        CurrByte: Byte;                                  { the current Byte }
        DecodeStack: array[0..MAXCODES] of Byte;    { stack for the decoded codes }
        Prefix: array[0..MAXCODES] of Integer;      { array for code prefixes }
        Suffix: array[0..MAXCODES] of Integer;      { array for code suffixes }
        LineBuffer: TGraphicLine;                    { array for buffer line output }
        CurrentX,
    CurrentY: Integer;                          { current screen locations }
        InterlacePass: Byte;                        { interlace pass number }
        { Bitmap Data }
        BmHeader: TBitmapInfoHeader;                { File Header for bitmap file }
    BmpStream: TMemoryStream;
        ImageLines: TList;                          { Image data }
    { Status Variables }
    FStatus: TGifStatus;
    CurStatus,
    MaxStatus: Integer;
    FFileName: TFileName;
        { Member Functions }
    procedure GifError(ErrorStr: String);
        procedure Decode;
    procedure GifDecode;
    procedure WriteStream;
    procedure ParseMem;
    procedure SetBitmap(newValue: TBitmap);
    function GetGifVersion: TGifVersion;
    procedure SetGifVersion(newValue: TGifVersion);
    function GetInterlaced: Boolean;
    procedure SetInterlaced(newValue: Boolean);
  protected
    procedure Draw(ACanvas: TCanvas; const Rect: TRect); override;
    function GetEmpty: Boolean; override;
    function GetHeight: Integer; override;
    function GetWidth: Integer; override;
    procedure ReadData(Stream: TStream); override;
    procedure SetHeight(Value: Integer); override;
    procedure SetWidth(Value: Integer); override;
    procedure WriteData(Stream: TStream); override;
    procedure ChangeStatus(LoadStatus: LongInt); virtual;
    procedure TriggerChangeEvent; virtual;
  public
        constructor Create;
        destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    procedure LoadFromFile(const Filename: string); override;
    procedure SaveToFile(const Filename: string); override;
    procedure LoadFromStream(Stream: TStream); override;
    procedure SaveToStream(Stream: TStream); override;
    property Bitmap: TBitmap read FBitmap write SetBitmap;
    property Status: TGifStatus read FStatus;
    procedure SaveToClipboardFormat(var AFormat: Word; var AData: THandle; var APalette: HPALETTE); override;
    procedure LoadFromClipboardFormat(AFormat: Word; AData: THandle; APalette: HPALETTE); override;
    property FileName: TFileName read FFileName;
  published
    property OnStatusChange: TStatusChangeEvent read FOnStatusChange write FOnStatusChange;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
    property GifVersion: TGifVersion read GetGifVersion write SetGifVersion;
    property Interlaced: Boolean read GetInterlaced write SetInterlaced;
    end;

  TGifImage = class(TGraphicControl)
  private
    FBorder: Boolean;
    FOnChange: TNotifyEvent;
    FFilename: TFilename;
    FGif: TGif;
    FOnStatusChange: TStatusChangeEvent;
    function GetFilename: TFilename;
    procedure SetFilename(newValue: TFilename);
    procedure SetGif(newValue: TGif);
    procedure SetBitmap(newValue: TBitmap);
    function GetBitmap: TBitmap;
    function GetBorder: Boolean;
    procedure SetBorder(newValue: Boolean);
  protected
    procedure Paint; override;
    procedure TriggerStatusChangeEvent(Sender: TObject; Status: TGifStatus); virtual;
    procedure TriggerChangeEvent; virtual;
    procedure GifChanged(Sender: TObject);
    procedure GifStatusChanged(Sender: TObject; Status: TGifStatus);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property Canvas;
    property Bitmap: TBitmap read GetBitmap;
  published
    property Gif: TGif read FGif write SetGif;
    property Align;
    property Color;
    property DragCursor;
    property DragMode;
    property Enabled;
    property ParentColor;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property Visible;
    property OnClick;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnStatusChange: TStatusChangeEvent read FOnStatusChange write FOnStatusChange;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
    property Border: Boolean read GetBorder write SetBorder default True;
  end;

    EGifException = class(Exception);

procedure Register;

implementation

uses
  ClipBrd;

function TGifImage.GetBorder: Boolean;
begin
  Result := FBorder;
end;  { GetBorder }

procedure TGifImage.SetBorder(NewValue: Boolean);
begin
  if FBorder <> NewValue then
  begin
    FBorder := NewValue;
    Repaint;
  end;
end;  { SetBorder }


{ General Purpose Functions }

function Power(A, N: Real): Real;
{ Returns A raised to the power of N }
begin
  Result := Exp(N * Ln(A));
end;

{ TGifImage }

procedure TGifImage.GifStatusChanged(Sender: TObject; Status: TGifStatus);
begin
  if Assigned(FOnStatusChange) then
    FOnStatusChange(Self, Status);
end;  { GifStatusChanged }

procedure TGifImage.GifChanged(Sender: TObject);
begin
  Repaint;
  TriggerChangeEvent;
end;  { GifChanged }

procedure TGifImage.TriggerChangeEvent;
begin
  if Assigned(FOnChange) then
    FOnChange(Self);
end;  { TriggerChangeEvent }

function TGifImage.GetFilename: TFilename;
begin
  Result := FFilename;
end;  {GetFilename}

procedure TGifImage.SetFilename(NewValue: TFilename);
begin
  if FFilename <> NewValue then
  begin
    FFilename := NewValue;
    FGif.LoadFromFile(FFilename);
    Repaint;
  end;
end;  {SetFilename}

procedure TGifImage.SetGif(NewValue: TGif);
begin
  FGif.Assign(NewValue);
  Repaint;
end;  {SetGif}

procedure TGifImage.SetBitmap(newValue: TBitmap);
begin
end;  {SetBitmap}

function TGifImage.GetBitmap: TBitmap;
begin
  if Assigned(FGif.FBitmap) and (not FGif.FBitmap.Empty) then
    Result := FGif.FBitmap
  else
    Result := nil;
end;

procedure TGifImage.Paint;
var
  Dest: TRect;
  AColor: TColor;
  Offset: Word;
begin
  AColor := Color;
  with inherited Canvas do
  begin
    Pen.Color := clBlack;
    if FBorder then
      Pen.Style := psSolid
    else
      Pen.Style := psClear;
    Brush.Style := bsSolid;
    Brush.Color := AColor;
    Rectangle(0, 0, Width, Height);
  end;
  WordBool(Offset) := FBorder;
  Dest := Rect(Offset, Offset, FGif.FBitmap.Width + Offset, FGif.FBitmap.Height + Offset);
  with inherited Canvas do
    StretchDraw(Dest, FGif.FBitmap);
end;

procedure TGifImage.TriggerStatusChangeEvent(Sender: TObject; Status: TGifStatus);
begin
  if Assigned(FOnStatusChange) then
    FOnStatusChange(Self, Status);
end;  {TriggerStatusChangeEvent}

constructor TGifImage.Create(AOwner:TComponent);
begin
  Color := clWindow;
  inherited Create(AOwner);
  FGif := TGif.Create;
  with FGif do
  begin
    OnChange := GifChanged;
    OnStatusChange := GifStatusChanged;
  end;
  Height := 105;
  Width := 105;
  FBorder := True;
end;

destructor TGifImage.Destroy;
begin
  FGif.Free;
  inherited Destroy;
end;

{ TGif }

type
    PBitmapLineStruct = ^TBitmapLineStruct;
    TBitmapLineStruct = record
        LineData: TGraphicLine;
        LineNo: Integer;
    end;

const
{ General Purpose Constants }
    BlockTerminator: Byte = 0;              { terminates stream of data blocks }
    Trailer: Byte = $3B;                          { indicates the end of the GIF data stream }
  ExtensionIntroducer: Byte = $21;
  ImageSeparator: Byte = $2C;

{ Image Descriptor Bit Masks }
    idLocalColorTable = $80;                  { set if a local color table follows }
    idInterlaced = $40;                            { set if image is interlaced }
    idSort = $20;                                      { set if color table is sorted }
    idReserved = $0C;                                { reserved - must be set to $00 }
    idColorTableSize = $07;                      { size of color table as above }

{ Logical Screen Descriptor Packed Field Masks }
    lsdGlobalColorTable = $80;                { set if global color table follows L.S.D. }
    lsdColorResolution = $70;                  { Color resolution - 3 bits }
    lsdSort = $08;                                    { set if global color table is sorted - 1 bit }
    lsdColorTableSize = $07;                  { size of global color table - 3 bits }
                                                              { Actual size = 2^value+1    - value is 3 bits }
{ Error Constants }
    ErrNoError = '';                                    { No errors found }
    ErrFileNotFound = 'GIF file was not found';         { Gif file not found }
    ErrNotGIF = 'Invalid GIF file format';               { File is not a gif file }
    ErrNoGlobalColor = 'GIF color table not found';     { No Global Color table found }
    ErrImagePreceded = 'Bad GIF image data';             { image descriptor preceeded by other unknown data }
    ErrEmptyBlock = 'GIF image has no data';               { Block has no data }
     ErrUnExpectedEOF = 'Unexpected end of GIF file';    { unexpected EOF }
    ErrBadCodeSize = 'Bad GIF code size';               { bad code size }
    ErrBadCode = 'Bad GIF code';                             { Bad code was found }
    ErrBitSizeOverflow = 'Bad GIF bit size';            { bit size went beyond 12 bits }
  ErrNoBMP = 'GIF is empty';                                 { Could not make BMP file }

{ Bit masks for use with NextCode }
CodeMask: array[0..12] of Integer = ($0000, $0001, $0003, $0007, $000F, $001F, $003F,
                                     $007F, $00FF, $01FF, $03FF, $07FF, $0FFF);

function TGif.GetGifVersion: TGifVersion;
begin
  case Ord(Header.Version[1]) of
    55: FGifVersion := v87a;
    57: FGifVersion := v89a;
  end;
  Result := FGifVersion;
end;  { GetGifVersion }

procedure TGif.SetGifVersion(newValue: TGifVersion);
begin
(*
  if FGifVersion <> newValue then
  begin
    FGifVersion := newValue;
  end;
*)
end;  { SetGifVersion }

function TGif.GetInterlaced: Boolean;
begin
  Result := FInterlaced;
end;  { GetInterlaced }

procedure TGif.SetInterlaced(newValue: Boolean);
begin
(*
  if FInterlaced <> NewValue then
  begin
    FInterlaced := NewValue;
  end;
*)
end;  { SetInterlaced }

procedure TGif.TriggerChangeEvent;
begin
  if Assigned(FOnChange) then
    FOnChange(Self);
end;  {TriggerChangeEvent}

procedure TGif.SetBitmap(NewValue: TBitmap);
begin
  if FBitmap <> NewValue then
  begin
    FBitmap.Assign(NewValue);
  end;
end;  {SetBitmap}

procedure TGif.Draw(ACanvas: TCanvas; const Rect: TRect);
begin
  StretchBlt(ACanvas.Handle, Rect.Left, Rect.Top, Rect.Right - Rect.Left,
      Rect.Bottom - Rect.Top, FBitmap.Canvas.Handle, 0, 0, Width, Height, ACanvas.CopyMode);
end;  {Draw}

function TGif.GetEmpty: Boolean;
begin
  Result := FBitmap.Empty;
end;  {GetEmpty}

function TGif.GetHeight: Integer;
begin
  Result := ImageDescriptor.ImageHeight;
end;  {GetHeight}

function TGif.GetWidth: Integer;
begin
  Result := ImageDescriptor.ImageWidth;
end;  {GetWidth}

procedure TGif.ReadData(Stream: TStream);
begin
  inherited ReadData(Stream);
end;  {ReadData}

procedure TGif.SetHeight(Value: Integer);
begin
{  TriggerChangeEvent;}
end;  {SetHeight}

procedure TGif.SetWidth(Value: Integer);
begin
{  TriggerChangeEvent;}
end;  {SetWidth}

procedure TGif.WriteData(Stream: TStream);
begin
  inherited WriteData(Stream);
end;  {WriteData}

procedure TGif.Assign(Source: TPersistent);
begin
  inherited Assign(Source);
end;  {Assign}

procedure TGif.LoadFromFile(const Filename: string);
begin
  if FFilename <> FileName then
  begin
    FFileName := FileName;
    if (UpperCase(ExtractFileExt(FFilename)) = '.GIF') and FileExists(FFilename) then
    begin
      GifStream.LoadFromFile(FFilename);             { Load the file into memory }
      GifDecode;
    end;
    TriggerChangeEvent;
  end;
end;  {LoadFromFile}

procedure TGif.SaveToFile(const Filename: string);
begin
(*
  if UpperCase(ExtractFileExt(Filename)) = '.BMP' then
  begin
    WriteStream;
    BmpStream.SaveToFile(Filename);
  end
  else
{    Error}
*)
end;  {SaveToFile}

procedure TGif.LoadFromStream(Stream: TStream);
begin
  if Assigned(Stream) then
  begin
    GifStream.LoadFromStream(Stream);
    GifDecode;
  end;
  TriggerChangeEvent;
end;  {LoadFromStream}

procedure TGif.SaveToStream(Stream: TStream);
var
  MemStream: TMemoryStream;
begin
  if Assigned(Stream) then
  begin
    MemStream := TMemoryStream.Create;
    WriteStream;
    MemStream.LoadFromStream(BmpStream);
    MemStream.SaveToStream(Stream);
    MemStream.Free;
  end;
end;  {SaveToStream}

destructor TGif.Destroy;
begin
  if Assigned(FBitmap) then FBitmap.Free;
  if Assigned(GifStream) then GifStream.Free;
  if Assigned(BmpStream) then BmpStream.Free;
  if Assigned(ImageLines) then ImageLines.Free;
  inherited Destroy;
end;  {Destroy}

constructor TGif.Create;
begin
  inherited Create;
  FBitmap := TBitmap.Create;
  GifStream := TMemoryStream.Create;
  BmpStream := TMemoryStream.Create;
  ImageLines := TList.Create;
  FStatus := 0;
  FFileName := '';
end;  {Create}

procedure TGif.GifDecode;

  {------------------------------------------------------------------------------}

  procedure CreateBitHeader;
  { This routine takes the values from the GIF
    image descriptor and fills in the appropriate
    values in the bitmap header struct }
  begin
    BmHeader.biSize := SizeOf(TBitmapInfoHeader);
    BmHeader.biWidth := ImageDescriptor.ImageWidth;
    BmHeader.biHeight := ImageDescriptor.ImageHeight;
    BmHeader.biPlanes := 1;                           { Arcane and rarely used }
    BmHeader.biBitCount := 8;                         { Should this be hardcoded? }
    BmHeader.biCompression := BI_RGB;                 { No compression in this version }
    BmHeader.biSizeImage := 0;                        { Because we are not compressing image }
    BmHeader.biXPelsPerMeter :=143;                   { Rarely used very arcane field }
    BmHeader.biYPelsPerMeter :=143;                   { Rarely used very arcane field }
    BmHeader.biClrUsed := 0;                          { all colors are used }
    BmHeader.biClrImportant := 0;                     { all colors are important }
  end;

  {------------------------------------------------------------------------------}

begin
  ParseMem;
  { Create the bitmap header info }
  MaxStatus := (ImageDescriptor.ImageHeight * 2);
  ChangeStatus(0);
  CreateBitHeader;
  { Decode the GIF }
  Decode;
  WriteStream;
end;

procedure TGif.Decode;

  {------------------------------------------------------------------------------}

  var
    SP: Integer;

  procedure DecodeCode(var Code: Word);           { Local procedure that decodes a }
  begin                                             { code and puts it on the decode stack }
    while Code > HighCode do                      { rip thru the prefix list placing suffixes }
    begin                                         { onto the decode stack }
      DecodeStack[SP] := Suffix[Code];            { put the suffix on the decode stack }
      inc(SP);                                    { increment decode stack index }
      Code := Prefix[Code];                       { get the new prefix }
    end;
    DecodeStack[SP] := Code;                        { put the last code onto the decode stack }
    inc(SP);                                            { increment the decode stack index }
  end; { DecodeCode }

  {------------------------------------------------------------------------------}

  procedure InitCompressionStream;
  begin
    GifStream.Read(LZWCodeSize, SizeOf(Byte));      { get minimum code size }
    if not (LZWCodeSize in [2..9]) then             { valid code sizes 2-9 bits }
       GifError(ErrBadCodeSize);
    CurrCodeSize := succ(LZWCodeSize);            { set the initial code size }
    ClearCode := 1 shl LZWCodeSize;               { set the clear code }
    EndingCode := succ(ClearCode);                { set the ending code }
    HighCode := pred(ClearCode);                       { set the highest code not needing decoding }
    BytesLeft := 0;                               { clear other variables }
    BitsLeft := 0;
    CurrentX := 0;
    CurrentY := 0;
  end; { InitCompressionStream }

  {------------------------------------------------------------------------------}

  procedure ReadSubBlock;
  begin
    GifStream.Read(ImageData.Size, SizeOf(ImageData.Size));   { get the data block size }
    if ImageData.Size = 0 then
      GifError(ErrEmptyBlock);                                                  { check for empty block }
    GifStream.Read(ImageData.Data, ImageData.Size);             { read in the block }
    NextByte := 1;                                            { reset next Byte }
    BytesLeft := ImageData.Size;                                      { reset Bytes left }
  end; { ReadSubBlock }

  {------------------------------------------------------------------------------}

  function NextCode: Word;                        { returns a code of the proper bit size }
  begin
    if BitsLeft = 0 then                            { any bits left in Byte ? }
    begin                                                     { any Bytes left }
      if BytesLeft <= 0 then                         { if not get another block }
        ReadSubBlock;
      CurrByte := ImageData.Data[NextByte];         { get a Byte }
      inc(NextByte);                                { set the next Byte index }
      BitsLeft := 8;                                { set bits left in the Byte }
      dec(BytesLeft);                               { decrement the Bytes left counter }
    end;
    Result := CurrByte shr (8 - BitsLeft);              { shift off any previosly used bits}
    while CurrCodeSize > BitsLeft do                { need more bits ? }
    begin
      if BytesLeft <= 0 then                                  { any Bytes left in block ? }
        ReadSubBlock;                             { if not read in another block }
      CurrByte := ImageData.Data[NextByte];          { get another Byte }
      inc(NextByte);                                 { increment NextByte counter }
      Result := Result or
          (CurrByte shl BitsLeft);                  { add the remaining bits to the return value }
      BitsLeft := BitsLeft + 8;                   { set bit counter }
      Dec(BytesLeft);                               { decrement Bytesleft counter }
    end;
    BitsLeft := BitsLeft - CurrCodeSize;          { subtract the code size from bitsleft }
    Result := Result and CodeMask[CurrCodeSize];  { mask off the right number of bits }
  end; { NextCode }

  {------------------------------------------------------------------------------}

  procedure CreateLine;
  {fills in Line list with current line}
  var
    p: PBitmapLineStruct;
  begin
    Application.ProcessMessages;
    New(p);                                       {Create a new bmp line}
    p^.LineData := LineBuffer;                    {Fill in the data}
    p^.LineNo := CurrentY;
    ImageLines.Add(p);                            { Add it to the list of lines }
    Inc(CurrentY);                                { Prepare for the next line }
    ChangeStatus(CurStatus + 1);
    if FInterlaced then                            { Interlace support }
    begin
      case InterlacePass of
        0: CurrentY := CurrentY + 7;
        1: CurrentY := CurrentY + 7;
        2: CurrentY := CurrentY + 3;
        3: CurrentY := CurrentY + 1;
        end;
      if CurrentY >= ImageDescriptor.ImageHeight then
      begin
        Inc(InterLacePass);
        case InterLacePass of
          1: CurrentY := 4;
          2: CurrentY := 2;
          3: CurrentY := 1;
        end;
      end;
    end;
  end; { CreateLine }

  {------------------------------------------------------------------------------}

var
    TempOldCode, OldCode: Word;
    BufCnt: Word;                      { line buffer counter }
    Code, C: Word;
    CurrBuf: Word;                    { line buffer index }
  MaxVal: Boolean;
begin
  InitCompressionStream;                          { Initialize decoding paramaters }
  OldCode := 0;
  SP := 0;
  BufCnt := ImageDescriptor.ImageWidth;           { set the Image Width }
  CurrBuf := 0;
  MaxVal := False;
  C := NextCode;                                          { get initial code - should be clear code }
  while C <> EndingCode do                        { main loop until ending code is found }
  begin
    if C = ClearCode then                            { code is clear code - so clear }
    begin
      CurrCodeSize := LZWCodeSize + 1;              { reset the code size }
      Slot := EndingCode + 1;                              { set slot for next new code }
      TopSlot := 1 shl CurrCodeSize;                { set max slot number }
      while C = ClearCode do
        C := NextCode;                              { read until all clear codes gone }
      if C = EndingCode then
        GifError(ErrBadCode);                       { ending code after a clear code }
      if C >= Slot then                           { if beyond preset codes then set to zero }
        C := 0;
      OldCode := C;
      DecodeStack[sp] := C;                         { output code to decoded stack }
      inc(SP);                                          { increment decode stack index }
    end
    else                                          { not  clear code or ending code so must }
    begin                                         { be a code code - so decode the code }
      Code := C;
      if Code < Slot then                         { is the code in the table? }
      begin
        DecodeCode(Code);                         { decode the code }
        if Slot <= TopSlot then
        begin                                           { add the new code to the table }
          Suffix[Slot] := Code;                        { make the suffix }
          PreFix[slot] := OldCode;                   { the previous code - a link to the data }
          inc(Slot);                                 { increment slot number }
          OldCode := C;                              { set oldcode }
        end;
        if Slot >= TopSlot then                       { have reached the top slot for bit size }
        begin                                       { increment code bit size }
          if CurrCodeSize < 12 then                 { new bit size not too big? }
          begin
            TopSlot := TopSlot shl 1;                { new top slot }
            inc(CurrCodeSize)                           { new code size }
          end
          else
            MaxVal := True;                             { Must check next code is a start code }
        end;
      end
      else
      begin                                          { the code is not in the table }
        if Code <> Slot then
          GifError(ErrBadCode);                   { so error out }
        { code does not exist, so make
          a new entry in the code table
          and then translate the new code }
        TempOldCode := OldCode;                   { make a copy of the old code }
        while OldCode > HighCode do                 { translate the old code and place it }
        begin                                            { on the decode stack }
          DecodeStack[SP] := Suffix[OldCode];     { do the suffix }
          OldCode := Prefix[OldCode];             { get next prefix }
        end;
        DecodeStack[SP] := OldCode;                  { put the code onto the decode stack
                                                    but DO NOT increment stack index }
        { the decode stack is not
          incremented because because
          we are only translating the oldcode
          to get the first Character }
        if Slot <= TopSlot then
        begin                                       { make new code entry }
          Suffix[Slot] := OldCode;                   { first Char of old code }
          Prefix[Slot] := TempOldCode;               { link to the old code prefix }
          inc(Slot);                                 { increment slot }
        end;
        if Slot >= TopSlot then                   { slot is too big }
        begin                                                  { increment code size }
          if CurrCodeSize < 12 then
          begin
            TopSlot := TopSlot shl 1;                { new top slot }
                inc(CurrCodeSize);                   { new code size }
          end
          else
              MaxVal := True;                           { Must check next code is a start code }
        end;
        DecodeCode(Code);                         { now that the table entry exists decode it }
        OldCode := C;                             { set the new old code }
      end;
    end;
    { the decoded string is on the decode
      stack so pop it off and put it into
      the line buffer }
    while SP > 0 do
    begin
      dec(SP);
      LineBuffer[CurrBuf] := DecodeStack[SP];
      inc(CurrBuf);
      dec(BufCnt);
      if BufCnt = 0 then                          { is the line full ? }
      begin
        CreateLine;
        CurrBuf := 0;
        BufCnt := ImageDescriptor.ImageWidth;
      end;
    end;
    C := NextCode;                                  { get the next code and go at is some more }
    if (MaxVal = True) and (C <> ClearCode) then
      GifError(ErrBitSizeOverflow);
    MaxVal := False;
  end;
end; { GifDecode }

procedure TGif.WriteStream;
var
  BitFile: TBitmapFileHeader;
  i,
  Line,
  x: Integer;
  Ch: Char;
  p: PBitmapLineStruct;
begin
  BitFile.bfSize := (3 * 255) + SizeOf(TBitmapFileHeader) + SizeOf(TBitmapInfoHeader) +
      (ImageDescriptor.ImageHeight * ImageDescriptor.ImageWidth);
  BitFile.bfReserved1 := 0;                       { Not currently used }
  BitFile.bfReserved2 := 0;                       { Not currently used }
  BitFile.bfOffBits := (4 * 256) + SizeOf(TBitmapFileHeader) + SizeOf(TBitmapInfoHeader);
  BmpStream.Clear;                                { Write the file header }
{  BmpStream.Seek(0,0);}
  Ch := 'B';
  BmpStream.Write(Ch, 1);
  Ch := 'M';
  BmpStream.Write(Ch, 1);
  BmpStream.Write(BitFile.bfSize, SizeOf(BitFile.bfSize));
  BmpStream.Write(BitFile.bfReserved1, SizeOf(BitFile.bfReserved1));
  BmpStream.Write(BitFile.bfReserved2, SizeOf(BitFile.bfReserved2));
  BmpStream.Write(BitFile.bfOffBits, SizeOf(BitFile.bfOffBits));
  BmpStream.Write(BmHeader, SizeOf(BmHeader));    { Write the bitmap image header info }
  { Write the RGB palete
    inforamtion to this file }
  if UseLocalColors then                          { Use the local color table }
  begin
    for i:= 0 to 255 do
    begin
      BmpStream.Write(LocalColorTable[i].Blue, 1);
      BmpStream.Write(LocalColorTable[i].Green, 1);
      BmpStream.Write(LocalColorTable[i].Red, 1);
      BmpStream.Write(Ch, 1);                     { Bogus palete entry required by windows }
    end;
  end
  else                                            { Use the global table }
  begin
    for i:= 0 to 255 do
    begin
      BmpStream.Write(GlobalColorTable[i].Blue, 1);
      BmpStream.Write(GlobalColorTable[i].Green, 1);
      BmpStream.Write(GlobalColorTable[i].Red, 1);
      BmpStream.Write(Ch, 1);                     { Bogus palete entry required by windows }
    end;
  end;
  Line := ImageDescriptor.ImageHeight;            { Init the Line Counter }
  {Write out File lines in reverse order}
  while Line >= 0 do
  begin
    { Go through the line list in reverse
      order looking for the current Line.
      Use reverse order since non interlaced
      gifs are stored top to bottom.  Bmp file
      needs to be written bottom to top }
    for i := (ImageLines.Count - 1) downto 0  do
    begin
      ChangeStatus(CurStatus + 1);
      p := ImageLines.Items[i];
      if p^.LineNo = Line then
      begin
        x := ImageDescriptor.ImageWidth;
        BmpStream.Write(p^.LineData, x);
        Ch := chr(0);
        while (x and 3) <> 0 do                   { Pad up to 4-Byte boundary with zeroes }
        begin
          Inc(x);
          BmpStream.Write(Ch, 1);
        end;
        Break;
      end;
    end;
    Dec(Line);
  end;
  BmpStream.Seek(0, 0);                           { Reset mewmory stream}
  FBitmap.LoadFromStream(BmpStream);
  ChangeStatus(0);
end; { WriteStream }

procedure TGif.ParseMem;
{ Decodes the header and palette info }
begin
  GifStream.Read(Header, SizeOf(Header));                     { read the header }
  if Header.Signature <> 'GIF' then
    GifError(ErrNotGif);                                          { is vaild signature? }
  GifStream.Read(LogicalScreen, SizeOf(LogicalScreen));       { Decode header information }
  if LogicalScreen.PackedFields and lsdGlobalColorTable = lsdGlobalColorTable then
  begin
    TableSize := Trunc(Power(2, (LogicalScreen.PackedFields and lsdColorTableSize) + 1));
    { Read Global Color Table }
    GifStream.Read(GlobalColorTable, TableSize * SizeOf(TColorItem));
  end
  else
    GifError(ErrNoGlobalColor);
  GifStream.Read(ImageDescriptor, SizeOf(ImageDescriptor));   { Read image descriptor }
  if ImageDescriptor.Separator <> ImageSeparator then         { Verify the descriptor }
    GifError(ErrImagePreceded);
  { Check for local color table }
  if ImageDescriptor.PackedFields and idLocalColorTable = idLocalColorTable then
  begin
    TableSize := Trunc(Power(2, (ImageDescriptor.PackedFields and idColorTableSize) + 1));
    { Read Local Color Table }
    GifStream.Read(LocalColorTable, TableSize * SizeOf(TColorItem));
    UseLocalColors := True;
  end
  else
    UseLocalColors := False;
  {Check for interlaced}
  FInterlaced := ImageDescriptor.PackedFields and idInterlaced = idInterlaced;
  if FInterlaced then
    InterlacePass := 0;
  { Reset then Expand capacity of the Image Lines list }
  ImageLines.Clear;
  ImageLines.Capacity := ImageDescriptor.ImageHeight;
  if (GifStream = nil) then
    GifError(ErrFileNotFound);
end; { ParseMem }

procedure TGif.ChangeStatus(LoadStatus: LongInt);
begin
  if LoadStatus > MaxStatus then
  begin
    FStatus := 100;
    CurStatus := MaxStatus;
  end
  else
  begin
    FStatus := Round((LoadStatus / MaxStatus) * 100);
    CurStatus := LoadStatus;
  end;
  if Assigned(FOnStatusChange) then
    FOnStatusChange(Self, FStatus);
end;  {TriggerStatusChangeEvent}

{Raise exception with a message}
procedure TGif.GifError(ErrorStr: String);
begin
  if ErrorStr > ' ' then
    raise EGifException.Create(ErrorStr);
end;

procedure TGif.SaveToClipboardFormat(var AFormat: Word; var AData: THandle; var APalette: HPALETTE);
begin
end;  { SaveToClipboardFormat }

procedure TGif.LoadFromClipboardFormat(AFormat: Word; AData: THandle; APalette: HPALETTE);
begin
end;  { LoadFromClipboardFormat }

procedure Register;
begin
end;  {Register}

end.